List Hot Keys for active Access Form

VBA

Standard module

ListHotKeys_s4p is called when you invoke the add-in. It can also be called on its own if you import this module into your application. While defined as a function, ListHotKeys_s4p could also be a sub since it doesn't return any value.

Option Compare Database 
Option Explicit 

'*************** Code Start *****************************************************
' module name: bas_ListHotKeys_s4p
'-------------------------------------------------------------------------------
' Purpose  : show a list of hot key assignments in the Debug window
'                 - see what has been used and resolve conflicts
'                 - determine what hasn't been used
' Author   : crystal (strive4peace)
' web site : https://msaccessgurus.com
' This code: https://msaccessgurus.com/tool/Addin_ListHotKeys.htm
' LICENSE  :
'   You may freely use and share this code, but not sell it.
'   Keep attribution. Mark your changes. Use at your own risk
'---
'  you can install this as an addin
'  alternately, you can import this module and hook it into your application
'  Clearly mark your changes and
'  ensure each user has the above link to free source code.
'-------------------------------------------------------------------------------
'           ListHotKeys_s4p
'-------------------------------------------------------------------------------
Function ListHotKeys_s4p() 
'200720, 200825, 230905
'loop through all controls on ActiveForm
'  and list Hot Key if Caption property has &
'see what next character is
'load into arry
'sort array alphbetically, correlate related arrays

   'CALLs
   '  SortStringArray3
   
   On Error GoTo Proc_Err 
   
   Dim ctl As Control _ 
      ,f As Form 
   
   Dim sCaption As String _ 
      ,sKey As String * 1 _ 
      ,sName As String _ 
      ,sMsg As String _ 
      ,i As Integer _ 
      ,iLenCaption As Integer _ 
      ,iNbrShortcut As Integer _ 
      ,iPos As Integer 
      
   Dim aKeys() As String _ 
      ,aCaptions() As String _ 
      ,aNames() As String 
   
   iNbrShortcut = 0 
   
   Set f = Screen.ActiveForm 
   
   With f 
      ReDim aKeys(1 To .Controls.Count)  'more than we'll need
      ReDim aCaptions(1 To .Controls.Count)  'more than we'll need
      ReDim aNames(1 To .Controls.Count)  'more than we'll need
      
      For Each ctl In .Controls 
         sName =  ""
         
         With ctl 

            sName = .Name 
            sCaption = .Caption 

            iLenCaption = Len(sCaption) 
            
            sKey =  ""
            iPos = 1 
            
            Do While iPos > 0 And iLenCaption > 0 
               iPos = InStr(iPos,sCaption, "&") 
            
               If iPos > 0 _ 
                     And iPos + 1 <= iLenCaption Then 
                  'see what next character is
                  iPos = iPos + 1 
                  sKey = Mid(sCaption,iPos) 
                  If sKey =  "&" Then 
                     sKey =  ""
                     'loop to look for next ampersand
                     iPos = iPos + 1 
                  Else 
                     iNbrShortcut = iNbrShortcut + 1 
                     aKeys(iNbrShortcut) = sKey 
                     aCaptions(iNbrShortcut) = sCaption 
                     aNames(iNbrShortcut) = sName 

                     iPos = -1  'stop loop
                  End If 
               End If 
            Loop 
   
         End With  'ctl
NextControl: 
      Next ctl 
   
   End With  'ActiveForm

   'done reading values
   
   Debug.Print  "*** Hot Keys for " & f.Name &  " in " & CurrentDb.Name 
   
   'if there are hot keys, then sort alphabetically
   If iNbrShortcut > 0 Then 
      ReDim Preserve aKeys(1 To iNbrShortcut) 
      ReDim Preserve aCaptions(1 To iNbrShortcut) 
      ReDim Preserve aNames(1 To iNbrShortcut) 
      
      Call SortStringArray3(aKeys,aCaptions,aNames) 
      'report hot keys
      sMsg =  "hot keys: " & Join(aKeys, ", ") _ 
         & vbCrLf & vbCrLf &  "Look at Immediate window for details"
            
      For i = 1 To iNbrShortcut 

         Debug.Print aKeys(i); 
         Debug.Print Tab(5); aCaptions(i); 
         Debug.Print Tab(30); aNames(i) 
      Next i 
      
   Else 
      'message that not hot keys found
      sMsg =  "No hot keys"
   End If 
      
   MsgBox sMsg,, "ListHotKeys_s4p"
   
Proc_Exit: 
   On Error Resume Next 
   Set ctl = Nothing 
   Set f = Nothing 
   Exit Function 

Proc_Err: 
If Err.Number = 438 Then Resume NextControl  'doesn't have Caption

   MsgBox Err.Description,,_ 
          "ERROR " & Err.Number _ 
        &  "   ListHotKeys_s4p"
 
   Resume Proc_Exit 
   'if you want to single-step code to find error, CTRL-Break at MsgBox
   'then right-click on "Resume" and choose --> Set Next Statement
   'press F8 to resume with the line that threw the error so you can inspect it
   Resume 

End Function 

'-------------------------------------------------------------------------------
'           SortStringArray3
'-------------------------------------------------------------------------------
Public Sub SortStringArray3(ByRef pArray() As String _ 
   ,ByRef pArray2() As String _ 
   ,ByRef pArray3() As String _ 
   ) 
'Sorts a single element string array
' + rearrange 2 other arrays to correlate - s4p
'200724 strive4peace
'based on bubble-sort code originally written by Brent Spaulding
         
   Dim s1 As String,s2 As String,s3 As String 
   Dim i As Integer 
   Dim j As Long 
   
   'Bubble sort the array
   If UBound(pArray) > 0 Then 
      j = UBound(pArray) 
      'loop through process for as many elements as there are
      Do Until j = 0 
         'start with next to last element
         'if it is greater, then swap them
         For i = LBound(pArray) To j - 1 
            If pArray(i) > pArray(i + 1) Then 
               s1 = pArray(i) 
               s2 = pArray2(i) 
               s3 = pArray3(i) 
               
               'rewrite element in first array
               pArray(i) = pArray(i + 1) 
               pArray(i + 1) = s1 
               
               'rewrite element in second array to correlate
               pArray2(i) = pArray2(i + 1) 
               pArray2(i + 1) = s2 
               
               'rewrite element in third array to correlate
               pArray3(i) = pArray3(i + 1) 
               pArray3(i + 1) = s3 
            End If 
         Next i 
         j = j - 1 
      Loop 
   End If 
            
End Sub 
'*************** Code End *****************************************************

Goto Top